The World of Computer Software/The World of Computer Software.iso/faq-s.zip/CHATSTUF.PAS

Pascal/Delphi Source File | 1991-04-16 | 59KB | 2,443 lines

{$R-,S-,I-,D-,F+,V-,B-,N-,L+ }
{$M 65500,0,0 }

unit chatstuf;

interface

uses crt,dos,
     gentypes,gensubs,subs1,userret,flags,mainr1,modem,windows,statret,
     configrt;

function specialcommand:boolean;
procedure specialseries;
procedure chat1 (gotospecial:boolean);
procedure chat2 (gotospecial:boolean);

implementation

const c1=15;
      c2=12;
      c3=15;
      c4=11;
      w2=24;
      w3=42;
      axis1=9;
      axis2=10;
      edituser:array [1..12] of string=
       ('┬───────────────────┬',
        '│ User Name         │',
        '│ User Level        │',
        '│ Xfer Level        │',
        '│ Xfer Points       │',
        '│ User Note         │',
        '│ Time Left         │',
        '│ Password          │',
        '│ G-File Level      │',
        '│ Board Access      │',
        '│ Sysop Access      │',
        '└───────────────────┘');
      utils:array [1..12] of string=
       ('┬───────────────────┬',
        '│ Hang up on User   │',
        '│ Delete User       │',
        '│ Snoop Mode [On]   │',
        '│ Snoop Mode [Off]  │',
        '└───────────────────┘',
        '',
        '',
        '',
        '',
        '',
        '');
      extra:array [1..12] of string=
       ('┬───────────────────────────┬',
        '│ Drop to DOS (part memory) │',
        '│ Run Setup Program         │',
        '│ Run User Editor           │',
        '│ Run Text Editor           │',
        '│ Run ANSI Editor           │',
        '└───────────────────────────┘',
        '',
        '',
        '',
        '',
        '');

var dscinc:array [1..6] of array [1..60] of word;
    Status:word;
type brdrrec = record
                TL,TH,TR,LV,RV,BL,BH,BR:char;
               end;

const border:brdrrec = (TL:'┌';TH:'─';TR:'┐';
                        LV:'│';       RV:'│';
                        BL:'└';BH:'─';BR:'┘');

{function specialcommand:boolean;

  function getstring (t:anystr):anystr;
  var mm,lz:anystr;
  begin
    textbackground (0);
    textcolor (15);
    gotoxy (axis1+3,axis2+2);
    write (usr,t);
    readline (mm);
    getstring:=mm;
  end;

  function getint (t:lstr):integer;
  var s:sstr;
  begin
    s:=getstring (t);
    getint:=valu(s)
  end;

  function getboo (t:lstr):boolean;
  var s:sstr;
  begin
    s:=getstring (t);
    getboo:=upcase(s[1])='Y'
  end;

 procedure box;

  (* procedure qbox (row,col,rows,cols:byte;wndwattr,brdrattr:integer;brdr:brdrrec);
   begin
    if (rows>=2) and (cols>=2) then
    begin
      with brdr do
      begin
        qwrite    (row       ,col                     ,brdrattr,TL);
        qfilleos  (                           1,cols-2,brdrattr,TH);
        qwriteeos (                                    brdrattr,TR);
        qfill     (row+1     ,col       ,rows-2,1     ,brdrattr,LV);
        qfill     (row+1     ,col+cols-1,rows-2,1     ,brdrattr,RV);
        qwrite    (row+rows-1,col                     ,brdrattr,BL);
        qfilleos  (                           1,cols-2,brdrattr,BH);
        qwriteeos (                                    brdrattr,BR);
        qfill     (row+1     ,col+1     ,rows-2,cols-2,wndwattr,' ')
     end;
    end;
   end; *)

  begin
  (* qstoretomem (axis1,axis2,6,60,dscinc);
   qbox (axis1,axis2,6,60,15,9,border); *)
  end;

  procedure done1;
  begin
  (* qstoretoscr (axis1,axis2,6,60,dscinc); *)
  end;

  procedure write1 (l:lstr);
  begin
   gotoxy (axis1+3,axis2+1);
   textcolor (15);
   textbackground (0);
   writeln (usr,l);
  end;

  procedure getnewtime;
  var q:integer;
      n:integer;
  begin
    n:=timeleft;
    box;
    write1 ('The user has '+strr(n)+' minutes left.');
    q:=getint ('New time left for today? ');
    if q>0 then begin
      urec.timetoday:=urec.timetoday+(q-n);
      writeurec;
      writeln ('You have been granted '+strr(timeleft)+' minutes for today.')
    end;
  end;

  procedure getnewlevel;
  var q,n:integer;
  begin
    box;
    write1 ('Current Level: '+strr(ulvl));
    q:=getint ('New Level [-1 to TRASH]: ');
    if q>0 then begin
     n:=q;
     ulvl:=n;
     urec.level:=n;
     writeurec;
     writeln ('You have been granted Level ',n,' access.');
     if n=-1 then writeln ('That means you''ve been thrown off this system. Hahah.')
    end
  end;

  procedure getnewgflevel;
  var q,n:integer;
  begin
    box;
    write1 ('Current G-File Level: '+strr(urec.gflevel));
    q:=getint ('New G-File Level: ');
    if q>0 then begin
     n:=q;
     urec.gflevel:=n;
     writeurec;
     writeln ('You have been granted Level ',n,' G-File access.');
    end
  end;

  procedure getnewaccess;
  var q,bname:sstr;
      bn:integer;
      ac:accesstype;
      wasopen:boolean;
      k:char;

    function inputaccess (q:sstr):accesstype;
    begin
      inputaccess:=invalid;
      if length(q)=0 then exit;
      case upcase(q[1]) of
        'L':inputaccess:=letin;
        'B':inputaccess:=bylevel;
        'K':inputaccess:=keepout
      end
    end;

    procedure getallaccess;

      procedure setallaccess (ac:accesstype);
      var cnt:integer;
      begin
        setalluserflags (urec,ac);
        writeln ('Your access to all sub-boards: ',accessstr[ac]);
        writeurec
      end;

    begin
      buflen:=1;
      q:=getstring ('ALL acc. ([B]y level, [L]et in, [K]eep out, or CR): ');
      ac:=inputaccess(q);
      if ac<>invalid then setallaccess(ac)
    end;

  var bd:boardrec;
  begin
    box;
    write1 ('Change Sub-Board Access');
    buflen:=10;
    bname:=getstring ('Which sub-board to change access for [''*''/All]: ');
    if length(bname)<1 then exit;
    if bname='*' then
      begin
        getallaccess;
        exit
      end;
    opentempbdfile;
    bn:=searchboard(bname);
    if bn=-1 then
      begin
        closetempbdfile;
        write1 ('No such board!  Press any key..');
        k:=bioskey;
        exit
      end;
    write1 ('Board '+bname+'... Current access: '+accessstr[getuseraccflag(urec,bn)]);
    buflen:=1;
    q:=getstring ('Access ([B]y level, [L]et in, [K]eep out, or [CR]: ');
    ac:=inputaccess(q);
    if ac=invalid then begin
      closetempbdfile;
      exit
    end;
    setuseraccflag (urec,bn,ac);
    writeurec;
    closetempbdfile;
    writeln ('New access for sub-board ',bname,': ',accessstr[ac])
  end;

  procedure hangupyn;
  var q:sstr;
  begin
    box;
    write1 ('Hang up on User');
    q:=getstring ('Hang up on him? [y/n]: ');
    if length(q)>0 then if upcase(q[1])='Y' then
      begin
        writeln (unam,' the System is going down.'^M^M);
        hangup;
        forcehangup:=true;
        specialcommand:=true
      end
  end;

  procedure getnewname;
  var m:mstr;
      n:integer;
      t:string[1];
  begin
    box;
    write1 ('Current Name: '+unam);
    m:=getstring ('New User Name: ');
    if length(m)<>0 then begin
      n:=lookupuser(m);
      if n<>0 then begin
        buflen:=1;
        t:=getstring ('Name already exists!  Are you sure? ');
        if upcase(t[1])<>'Y' then exit
      end;
      unam:=m;
      urec.handle:=m;
      writeurec;
      writeln ('Your Name has been changed to ',unam,'.')
    end
  end;

  procedure getnewpassword;
  var m:mstr;
  begin
    box;
    write1 ('Current Password: '+urec.password);
    m:=getstring ('New Password: ');
    if length(m)<>0 then
    begin
      urec.password:=m;
      writeurec;
      writeln ('Your Password has been changed.')
    end
  end;

  procedure getxferlevel;
  var i:integer;
  begin
    box;
     write1 ('Current Xfer Level: '+strr(urec.udlevel));
     i:=getint ('New File Xfer Level: ');
     if i<0 then exit
      else begin
       writeln ('You have been granted Level ',i,' File Xfer access.');
       urec.udlevel:=i;
       writeurec;
      end;
  end;

  procedure getxferpoints;
  var i:integer;
  begin
   box;
    write1 ('Current Xfer Points: '+strr(urec.udpoints));
    i:=getint ('New File Xfer Points: ');
     if i<0 then exit
      else begin
       writeln ('You have been granted ',i,' File Xfer points.');
       urec.udpoints:=i;
       writeurec;
      end;
  end;

  procedure snoopmode;
  begin
    box;
    write1 ('All I/O to the modem is locked.');
    delay (500);
    modeminlock:=true;
    setoutlock (true)
  end;

  procedure unsnoop;
  begin
    box;
    write1 ('All I/O to the modem is re-enabled.');
    delay (500);
    modeminlock:=false;
    setoutlock (false)
  end;

  procedure makenote;
  var mastermind:mstr;
  begin
   box;
   write1 ('Current Note: '+urec.note);
   buflen:=30;
   mastermind:=getstring ('New Note: ');
   if length(mastermind)<>0 then begin
    urec.note:=mastermind;
    writeurec;
    writeln ('Your User Note has been changed to: ',mastermind);
   end;
  end;

  procedure gotodos (i:integer);
  begin
    writeln ('Sysop in DOS:');
    window (1,1,80,25);
    gotoxy (1,25);
    writeln (usr,^M^J^J^J);
    updateuserstats (false);
    execcomcom;
  end;

  procedure runconfig;
  begin
    window (1,1,80,25);
    textbackground(0);
    gotoxy (1,25);
    writeln (usr,^M^J^J^J);
    updateuserstats (false);
    ensureclosed;
    if faqdir[length(faqdir)]<>'\' then faqdir:=faqdir+'\';
    cursor (true);
    Exec(GetEnv('COMSPEC'), '/C '+faqdir+'SETUP.EXE');
    cursor (false);
    readconfig;
    if datascrambling then scrambled:=true else scrambled:=false;
    chdir (copy(faqdir,1,length(faqdir)-1));
  end;

  procedure dotexteditor;
  begin
    textbackground(0);
    if length(editor)<1 then exit;
    writeln ('Sysop is loading text editor:');
    window (1,1,80,25);
    gotoxy (1,25);
    writeln (usr,^M^J^J^J);
    updateuserstats (false);
    ensureclosed;
    cursor (true);
    exec(GetEnv('COMSPEC'), '/C '+editor);
    cursor (false);
    chdir (copy(faqdir,1,length(faqdir)-1));
  end;

  procedure doansieditor;
  begin
    textbackground(0);
    if length(ansiedit)<1 then exit;
    writeln ('Sysop is loading ansi editor:');
    window (1,1,80,25);
    gotoxy (1,25);
    writeln (usr,^M^J^J^J);
    updateuserstats (false);
    ensureclosed;
    cursor (true);
    exec(GetEnv('COMSPEC'), '/C '+ansiedit);
    cursor (false);
    chdir (copy(faqdir,1,length(faqdir)-1));
  end;

  procedure printf (fn:lstr);

  procedure getextension (var fname:lstr);

    procedure tryfiles (a,b,c,d:integer);
    var q:boolean;

      function tryfile (n:integer):boolean;
      const exts:array [1..4] of string[3]=('','ANS','ASC','40');
      begin
        if not exist (fname+'.'+exts[n]) then tryfile:=false else begin
          tryfile:=true;
          fname:=fname+'.'+exts[n]
        end
      end;

    begin
      if tryfile (a) then exit;
      if tryfile (b) then exit;
      if tryfile (c) then exit;
      q:=tryfile (d)
    end;

  begin
    if pos ('.',fname)<>0 then exit;
    if ansigraphics in urec.config  then tryfiles (2,3,1,4) else
    if asciigraphics in urec.config then tryfiles (3,1,4,2) else
    if eightycols in urec.config    then tryfiles (1,4,3,2) else
                                         tryfiles (4,1,3,2)
  end;

var tf:text;
    k:char;
begin
  clearbreak;
  writeln;
  getextension (fn);
  assign (tf,fn);
  reset (tf);
  iocode:=ioresult;
  if iocode<>0 then begin
    fileerror ('Printfile',fn);
    exit
  end;
  clearbreak;
  while not (eof(tf) or break or hungupon) do
    begin
      read (tf,k);
      write (k)
    end;
  if break then writeln (^B);
  writeln;
  textclose (tf);
  curattrib:=0;
  ansireset
end;

  procedure nuke;
  var q:sstr;
      u:userrec;
      n,x:integer;
  begin
    box;
    q:=getstring ('Delete User? [y/n]: ');
    if length(q)>0 then if upcase(q[1])='Y' then
      begin
        write1 ('You''re Deleted!');
        deleteuser (unum);
         for n:=1 to numusers do begin
         seek (ufile,n);
         read (ufile,u);
         for x:=1 to 50 do
         u.newvoteit[x]:=0;
         writeufile (u,n);
         end;
         readurec;
        if exist (textfiledir+'Delete') then
         printf (textfiledir+'Delete') else
        writeln ('Don''t Call Again!'^M^M);
        hangup;
        forcehangup:=true;
        specialcommand:=true
      end
  end;

  procedure getsysopaccess;
  const sysopstr:array [false..true] of string[6]=('Normal','Sysop');
        sectionnames:array [udsysop..gfsysop] of string[20]=
          ('File Transfer','Bulletin Section','Voting Booths',
           'E-Mail Section','Doors','Main Menu','Databases','Trivia Sysop',
           'G-File Section');
  var cnt:configtype;
      x:string[10];
      n,mx:integer;
      v:boolean;
  begin
    repeat
      splitscreen (12);
      clrscr; textbackground(0);
      textcolor (15);
      mx:=1;
      for cnt:=udsysop to gfsysop do begin
        write (usr,mx:3,'. ',sectionnames[cnt]);
        mx:=mx+1;
        gotoxy (25,wherey);
        writeln (usr,sysopstr[cnt in urec.config])
      end;
      write (usr,^M^J'Number to toggle [CR/Exit]: ');
      buflen:=1;
      readline (x);
      n:=valu(x);
      v:=(n>0) and (n<mx);
      if v then begin
        cnt:=configtype(ord(udsysop)+n-1);
        if cnt in urec.config
          then
            begin
              urec.config:=urec.config-[cnt];
              x:='denied'
            end
          else
            begin
              urec.config:=urec.config+[cnt];
              x:='granted'
            end;
        writeln ('You have been ',x,' sysop priveleges for the ',
                 sectionnames[cnt],'.')
      end
    until not v;
    writeurec;
    clrscr;
    splitscreen (17);
    exit;
  end;

  procedure runusereditor;
  begin
    window (1,1,80,25);
    gotoxy (1,25);
    textbackground (0);
    writeln (usr,^M^J^J^J);
   (* updateuserstats (false);
    ensureclosed; *)
    if faqdir[length(faqdir)]<>'\' then faqdir:=faqdir+'\';
    Exec(GetEnv('COMSPEC'), '/C FAQUE.EXE');
    if datascrambling then scrambled:=true else scrambled:=false;
    clrscr;
  end;

procedure cursor (csize:byte);
var regs:registers;
begin
   case (csize) of
      1: if mem[0:$449]=7 then regs.cx:=$0c0d  (* Underline  = 1 *)
         else regs.cx:=$0607;
      2: if mem[0:$449]=7 then regs.cx:=$060d  (* Full Block = 2 *)
         else regs.cx:=$0007;
      3: regs.cx:=$2000;                       (* No Cursor  = 3 *)
   end;
   regs.ax:=$0100;
   intr ($10,regs);
end;

const memrows=25;
      memcols=80;
var scom:char;
    k,c:char;
    quit:boolean;
    x,y:integer;

procedure writetop;
begin
  gotoxy (1,1);
  textbackground (1);
  textcolor (c1);
  cursor (3);
  writeln (usr,'┌───────────────────────────────────────────────────────────────────────┐');
  write (usr,'│ ');
  textcolor (c1);
  write (usr,'User Editing          Utilities         Extra Commands');
  textcolor (c1);
  writeln (usr,'                │');
  writeln (usr,'└───────────────────────────────────────────────────────────────────────┘');
 (* gotoxy (1,16);
  textcolor (15);
  textbackground (4);

  write (usr,'[   Sysop Pull Down Menu System - '+#24+','+#25+','+#26+','+#27+',Home,End to Move - [CR] to Select   ]');
*) textbackground (0);
end;

procedure writebar (s:anystr);
var monolith:integer;
begin
 textbackground (1);
 textcolor (11);
 for monolith:=1 to length(s) do
 begin
  if s[monolith] in [' '..'~'] then begin
   textbackground (1);
   textcolor (11);
   write (usr,s[monolith]);
  end else
  begin
   textbackground (1);
   textcolor (15);
   write (usr,s[monolith]);
  end;
 end;
 textbackground (1);
end;

procedure movebar (xx:integer; dir:char);
var satan,dogchild,floyd:integer;
begin
 dir:=upcase(dir);
 case x of
  1:begin
     textcolor (c1);
     textbackground (1);
     satan:=y;
     gotoxy (3,satan+2);
     write (usr,edituser[satan]);
     if dir='U' then y:=y-1 else
     if dir='D' then y:=y+1 else
     if dir='S' then y:=y;
     if y>11 then y:=2;
     if y<2 then y:=11;
     gotoxy (3,y+2);
     writebar (edituser[y]);
    end;
  2:begin
     textcolor (c1);
     textbackground (1);
     dogchild:=y;
     gotoxy (w2,dogchild+2);
     write (usr,utils[dogchild]);
     if dir='U' then y:=y-1 else
     if dir='D' then y:=y+1 else
     if dir='S' then y:=y;
     if y>5 then y:=2;
     if y<2 then y:=5;
     gotoxy (w2,y+2);
     writebar (utils[y]);
    end;
  3:begin
     textcolor (c1);
     textbackground (1);
     floyd:=y;
     gotoxy (w3,floyd+2);
     write (usr,extra[floyd]);
     if dir='U' then y:=y-1 else
     if dir='D' then y:=y+1 else
     if dir='S' then y:=y;
     if y>6 then y:=2;
     if y<2 then y:=6;
     gotoxy (w3,y+2);
     writebar (extra[y]);
    end;
 end;
end;

procedure movebox (ex,ey:integer);
var anarky,burger,two:integer;
begin
 cursor (3);
 case ex of
  1:begin
     if x=2 then begin
      gotoxy (w2,2);
      textcolor (c1);
      textbackground (1);
      write (usr,' Utilities');
      textcolor (c1);
      gotoxy (w2,3);
      write (usr,'───────────────────────────');
     end else
     if x=3 then begin
      gotoxy (w3,2);
      textcolor (c1);
      textbackground (1);
      write (usr,' Extra Commands');
      textcolor (c1);
      gotoxy (w3,3);
      write (usr,'─────────────────────────────');
     end;
     x:=1;
     gotoxy (3,2);
     textbackground (1);
     textcolor (c4);
     write (usr,'User Editing');
     textcolor (c3);
     for anarky:=1 to 12 do
     begin
      gotoxy (3,anarky+2);
      write (usr,edituser[anarky]);
     end;
     if y>10 then y:=1;
     textbackground (1);
    end;
  2:begin
     if x=1 then begin
      gotoxy (3,2);
      textcolor (c1);
      textbackground (1);
      write (usr,'User Editing');
      textcolor (c1);
      gotoxy (3,3);
      write (usr,'─────────────────────');
     end else
     if x=3 then begin
      gotoxy (w3,2);
      textcolor (c1);
      textbackground (1);
      write (usr,' Extra Commands');
      textcolor (c1);
      gotoxy (w3,3);
      write (usr,'─────────────────────────────');
     end;
     x:=2;
     gotoxy (w2,2);
     textbackground (1);
     textcolor (c4);
     write (usr,' Utilities');
     textcolor (c3);
     for burger:=1 to 6 do
     begin
      gotoxy (w2,burger+2);
      write (usr,utils[burger]);
      textbackground (1);
      textcolor (c3);
     end;
    end;
  3:begin
     if x=1 then begin
      gotoxy (3,2);
      textcolor (c1);
      textbackground (1);
      write (usr,'User Editing');
      textcolor (c1);
      gotoxy (3,3);
      write (usr,'─────────────────────');
     end else
     if x=2 then begin
      gotoxy (w2,2);
      textcolor (c1);
      textbackground (1);
      write (usr,' Utilities');
      textcolor (c1);
      gotoxy (w2,3);
      write (usr,'──────────────────────');
     end;
     x:=3;
     gotoxy (w3,2);
     textbackground (1);
     textcolor (c4);
     write (usr,' Extra Commands');
     textcolor (c3);
     for two:=1 to 7 do
     begin
      gotoxy (w3,two+2);
      write (usr,extra[two]);
      textbackground (1);
      textcolor (c3);
     end;
    end;
 end;
end;

procedure eraseall;
begin
(* qfill (4,1,11,80,black+blackbg,' '); *)
 textbackground (0);
 clrscr;
 writetop;
end;

procedure movedown (x,y:integer);
begin
 movebar (x,'D');
end;

procedure moveup (x,y:integer);
begin
 movebar (x,'U');
end;

procedure moveright (x,y:integer);
begin
 y:=1;
 x:=x+1;
 if x>3 then x:=1;
 eraseall;
 y:=1;
 movebox (x,y);
 movebar (x,'S');
end;

procedure moveleft (x,y:integer);
begin
 y:=1;
 x:=x-1;
 if x<1 then x:=3;
 eraseall;
 y:=1;
 movebox (x,y);
 y:=1;
 movebar (x,'S');
end;

function processcommand:char;
begin
 cursor (1);
 case x of
  1:begin
     case y of
      2:getnewname;
      3:getnewlevel;
      4:getxferlevel;
      5:getxferpoints;
      6:makenote;
      7:getnewtime;
      8:getnewpassword;
      9:getnewgflevel;
      10:getnewaccess;
      11:getsysopaccess;
     end;
    end;
  2:begin
     case y of
      2:hangupyn;
      3:nuke;
      4:snoopmode;
      5:unsnoop;
     end;
    end;
  3:begin
     case y of
      2:begin gotodos (1); clrscr; end;
      3:begin runconfig; clrscr; end;
      4:begin runusereditor; clrscr; end;
      5:begin dotexteditor; clrscr; end;
      6:begin doansieditor; clrscr; end;
     end;
    end;
 end;
 cursor (3);
 case x of
  1:begin
     case y of
      2:processcommand:='N';
      3:processcommand:='L';
      4:processcommand:='F';
      5:processcommand:='F';
      6:processcommand:='R';
      7:processcommand:='T';
      8:processcommand:='P';
      9:processcommand:='G';
      10:processcommand:='B';
      11:processcommand:='Y';
     end;
    end;
  2:begin
     case y of
      2:processcommand:='H';
      3:processcommand:='N';
      4:begin
         processcommand:='S';
         quit:=true;
        end;
      5:begin
         processcommand:='Z';
         quit:=true;
        end;
     end;
    end;
  3:begin
     case y of
      2:processcommand:='D';
      3:processcommand:='C';
      4:processcommand:='U';
      5:processcommand:='E';
      6:processcommand:='A';
     end;
     quit:=true;
    end;
 end;
 done1;
end;

begin
  writeln (^B^M'Please Wait:');
  splitscreen (17);
  top;
  clrscr;
  specialcommand:=false;
  x:=1;
  y:=2;
  writetop;
  movebox (x,y);
  movebar (x,'S');
  quit:=false;
  repeat
   c:=bioskey;
   case ord(c) of
    27:begin
        quit:=true;
        scom:='Q';
       end;
    13:scom:=processcommand;
    208:movedown (x,y);
    200:moveup (x,y);
    203:moveleft (x,y);
    205:moveright (x,y);
    199:begin
         y:=2;
         movebox (x,y);
         movebar (x,'S');
        end;
    207:begin
         if x>1 then y:=5 else y:=11;
         movebox (x,y);
         movebar (x,'S');
        end;
   end;
  until quit;
  cursor (1);
  bottomline;
  specialcommand:=scom in ['Q','S','Z','D','C','U','E'];
  unsplit
end;}

Function specialcommand:Boolean;

  Procedure getnewtime;
    Var q:sstr;
      n:Integer;
    Begin
      n:=timeleft;
      WriteLn(Usr,'The user has ',n,' minutes left.');
      Write(Usr,'New Time Left: ');
      cursor (true);
      readline(q);
      cursor (false);
      If Length(q)>0 Then Begin
        urec.timetoday:=urec.timetoday+(valu(q)-n);
        writeurec;
        {      writeln ('You have been granted ',timeleft,' minutes for today.')
      }End
    End;

  Procedure getnewlevel;
    Var q:sstr;
      n:Integer;
    Begin
      WriteLn(Usr,'Current Main Level: ',ulvl);
      Write(Usr,'New Main Level [-1 to trash]: ');
      cursor (true);
      readline(q);
      cursor (false);
      If Length(q)>0 Then Begin
        n:=valu(q);
        ulvl:=n;
        urec.level:=n;
        writeurec;
        {    writeln ('You have been granted level ',n,' access.');
        if n=-1 then writeln ('That means you''ve been kicked off this system.')
      }End
    End;


  Procedure gfilez;
    Var q:sstr;
      n:Integer;
    Begin

      WriteLn(Usr,'Current G-File level: ',urec.gflevel);
      Write(Usr,'New G-File Level: ');
      cursor (true);
      readline(q);
      cursor (false);
      If Length(q)>0 Then Begin
        n:=valu(q);
        urec.gflevel:=n;
        writeurec;
      End;
    End;

  Procedure hangupyn;
    Var q:sstr;
    Begin
      textbackground (0);
      gotoxy (1,13);
      Write(Usr,'Hang Up on User? ');
      cursor (true);
      readline(q);
      cursor (false);
      If Length(q)>0 Then If UpCase(q[1])='Y' Then
        Begin
          WriteLn('Call back later!'^M);
          hangup;
          forcehangup:=True;
          specialcommand:=True
        End
    End;

  Procedure getnewname;
    Var m:mstr;
      n:Integer;
      t:String[1];
    Begin
      WriteLn(Usr,'Current Handle: ',unam);
      Write(Usr,'New Handle: ');
      cursor (true);
      readline(m);
      cursor (false);
      If Length(m)<>0 Then Begin
        n:=lookupuser(m);
        If n<>0 Then Begin
          Write(Usr,'Name already exists!  Are you sure? ');
          BufLen:=1;
          cursor (true);
          readline(t);
          buflen:=80;
          cursor (false);
          If UpCase(t[1])<>'Y' Then exit
        End;
        unam:=m;
        urec.handle:=m;
        writeurec;
    End;End;

  Procedure getnewpassword;
    Var m:mstr;
    Begin
      WriteLn(Usr,'Current Password: ',urec.password);
      Write(Usr,'New Password: ');
      cursor (true);
      readline(m);
      cursor (false);
      If Length(m)<>0 Then Begin
        urec.password:=m;
        writeurec;
      End
    End;

  Procedure getnewudlvl;
    Var m:mstr;
       i:integer;
    Begin
      WriteLn(Usr,'Current Xfer Level:  ',urec.udlevel);
      write (usr,'New Xfer Level: ');
      cursor (true);
      readline(m);
      cursor (false);
      If Length(m)>0 Then Begin
      i:=valu(m);
      urec.udlevel:=i;
      writeurec;

      End
    End;

  Procedure getnewudpts;
    Var m:mstr;
       i:integer;
    Begin
      WriteLn(Usr,'Current Xfer Points:  ',urec.udpoints);
      write (usr,'New Xfer Points: ');
      cursor (true);
      readline(m);
      cursor (false);
      If Length(m)>0 Then Begin
      i:=valu(m);
      urec.udpoints:=i;
      writeurec;

      End
    End;

  procedure printf (fn:lstr);

  procedure getextension (var fname:lstr);

    procedure tryfiles (a,b,c,d:integer);
    var q:boolean;

      function tryfile (n:integer):boolean;
      const exts:array [1..4] of string[3]=('','ANS','ASC','40');
      begin
        if not exist (fname+'.'+exts[n]) then tryfile:=false else begin
          tryfile:=true;
          fname:=fname+'.'+exts[n]
        end
      end;

    begin
      if tryfile (a) then exit;
      if tryfile (b) then exit;
      if tryfile (c) then exit;
      q:=tryfile (d)
    end;

  begin
    if pos ('.',fname)<>0 then exit;
    if ansigraphics in urec.config  then tryfiles (2,3,1,4) else
    if asciigraphics in urec.config then tryfiles (3,1,4,2) else
    if eightycols in urec.config    then tryfiles (1,4,3,2) else
                                         tryfiles (4,1,3,2)
  end;

var tf:text;
    k:char;
begin
  clearbreak;
  writeln;
  getextension (fn);
  assign (tf,fn);
  reset (tf);
  iocode:=ioresult;
  if iocode<>0 then begin
    fileerror ('Printfile',fn);
    exit
  end;
  clearbreak;
  while not (eof(tf) or break or hungupon) do
    begin
      read (tf,k);
      write (k)
    end;
  if break then writeln (^B);
  writeln;
  textclose (tf);
  curattrib:=0;
  ansireset
end;

  procedure nuke;
  var q:sstr;
      u:userrec;
      n,x:integer;
  begin
      textbackground (0);
      gotoxy (1,13);
      Write(Usr,'Delete User? ');
      cursor (true);
      readline(q);
      cursor (false);
      If Length(q)>0 Then If UpCase(q[1])='Y' Then
        Begin
        writeln ('You''re Deleted!'^M);
        deleteuser (unum);
         for n:=1 to numusers do begin
         seek (ufile,n);
         read (ufile,u);
         for x:=1 to 50 do
         u.newvoteit[x]:=0;
         writeufile (u,n);
         end;
         readurec;
        if exist (textfiledir+'Delete') then
         printf (textfiledir+'Delete') else
        writeln ('Don''t Call Again!'^M^M);
        hangup;
        forcehangup:=true;
        specialcommand:=true
      end
  end;

  Procedure snoopmode;
    Begin
      WriteLn(Usr,'All I/O to the modem is locked.');
      modeminlock:=True;
      setoutlock(True)
    End;

  Procedure unsnoop;
    Begin
      WriteLn(Usr,'I/O to the modem is re-enabled.');
      modeminlock:=False;
      setoutlock(False)
    End;

  procedure gotodos;
  begin
    writeln ('Sysop in DOS:');
    window (1,1,80,25);
    gotoxy (1,25);
    writeln (usr,^M^J^J^J);
    {updateuserstats (false);}
    cursor (true);
    execcomcom;
    cursor (false);
  end;

  procedure runconfig;
  begin
    window (1,1,80,25);
    textbackground(0);
    gotoxy (1,25);
    writeln (usr,^M^J^J^J);
   (* updateuserstats (false);
    ensureclosed; *)
    if faqdir[length(faqdir)]<>'\' then faqdir:=faqdir+'\';
    cursor (true);
    Exec(GetEnv('COMSPEC'), '/C '+faqdir+'SETUP.EXE');
    cursor (false);
    readconfig;
    if datascrambling then scrambled:=true else scrambled:=false;
    chdir (copy(faqdir,1,length(faqdir)-1));
  end;

  procedure dotexteditor;
  begin
    textbackground(0);
    if length(editor)<1 then exit;
    writeln ('Sysop is loading text editor:');
    window (1,1,80,25);
    gotoxy (1,25);
    writeln (usr,^M^J^J^J);
   (* updateuserstats (false);
    ensureclosed; *)
    cursor (true);
    exec(GetEnv('COMSPEC'), '/C '+editor);
    cursor (false);
    chdir (copy(faqdir,1,length(faqdir)-1));
  end;

  procedure doansieditor;
  begin
    textbackground(0);
    if length(ansiedit)<1 then exit;
    writeln ('Sysop is loading ansi editor:');
    window (1,1,80,25);
    gotoxy (1,25);
    writeln (usr,^M^J^J^J);
   (* updateuserstats (false);
    ensureclosed; *)
    cursor (true);
    exec(GetEnv('COMSPEC'), '/C '+ansiedit);
    cursor (false);
    chdir (copy(faqdir,1,length(faqdir)-1));
  end;

  Procedure getsysopaccess;
    Const sysopstr:Array[false..true] Of String[6]=('Normal','Sysop');
      sectionnames:Array[udsysop..databasesysop] Of String[20]=
      ('File transfer','Bulletin section','Voting booths',
      'E-mail section','Doors','Main menu','Databases');
    Var cnt:configtype;
      x:String[10];
      n,mx:Integer;
      v:Boolean;
    Begin
      Repeat
        ClrScr;
        mx:=1;
        For cnt:=udsysop To databasesysop Do Begin
          Write(Usr,mx:3,'. ',sectionnames[cnt]);
          mx:=mx+1;
          GoToXY(25,WhereY);
          WriteLn(Usr,sysopstr[cnt In urec.config])
        End;
        Write(Usr,^M^J'Number to toggle [CR to exit]: ');
        BufLen:=1;
        cursor (true);
        readline(x);
        cursor (false);
        n:=valu(x);
        v:=(n>0) And (n<mx);
        If v Then Begin
          cnt:=configtype(Ord(udsysop)+n-1);
          If cnt In urec.config
          Then
            Begin
              urec.config:=urec.config-[cnt];
              x:='denied'
            End
          Else
            Begin
              urec.config:=urec.config+[cnt];
              x:='granted'
            End;
          {      writeln ('You have been ',x,' sysop priveleges for the ',
          sectionnames[cnt],'.')
        }End
      Until Not v;
      writeurec
    End;

procedure Pulldownmenu;

procedure ahigh (x:integer);
var c:char;
    y,z,a:integer;
    dir:string[127];

begin
    case x of
      1:begin
            gotoxy (2,3);
            textbackground (1);
            textcolor (15);
            write (usr,' Root Directory ');
            textbackground (15);
            textcolor (4);
        end;
      2:begin
            gotoxy (2,4);
            textbackground (1);
            textcolor (15);
            write (usr,' Other Dir      ');
            textbackground (15);
            textcolor (4);
        end;
    end;
end;


procedure high (x:integer);
begin
     case x of
      1:begin
            gotoxy (2,2);
            textbackground (7);
            textcolor (15);
            write (usr,' User Editor ');
        end;
      2:begin
            gotoxy (16,2);
            textbackground (7);
            textcolor (15);
            write (usr,' External ');
        end;
      3:begin
            gotoxy (27,2);
            textbackground (7);
            textcolor (15);
            write (usr,' Shell to DOS ');
        end;
      4:begin
            gotoxy (42,2);
            textbackground (7);
            textcolor (15);
            write (usr,' Hang Up ');
        end;
      5:begin
            gotoxy (52,2);
            textbackground (7);
            textcolor (15);
            write (usr,' Delete User ');
        end;
      6:begin
            gotoxy (66,2);
            textbackground (7);
            textcolor (15);
            write (usr,' Help ');
        end;
      7:begin
            gotoxy (73,2);
            textbackground (7);
            textcolor (15);
            write (usr,' Quit ');
        end;
     end;
end;

procedure dohelp;
begin
     gotoxy (25,10);
     textbackground (1);
     textcolor (15);
     writeln (usr,'┌──────────────────────┐');
     gotoxy (25,11);
     write (usr,'│  ');
     textcolor (11);
     write (#27,#26,#25,#24+' - Move Bar');
     textcolor (15);
     writeln (usr,'     │');
     gotoxy (25,12);
     write (usr,'│ ');
     textcolor (11);
     write (usr,' [Return] - Select');
     textcolor (15);
     writeln (usr,'   │');
     gotoxy (25,13);
     write (usr,'│ ');
     textcolor (11);
     write (usr,' ESC - Quits to Main ');
     textcolor (15);
     writeln (usr,'│');
     gotoxy (25,14);
     writeln (usr,'└──────────────────────┘');
     repeat
     until keypressed;
end;


procedure changedir2;
var c:char;
    x,y,z,a:integer;
    dir:string[127];

begin
     gotoxy (6,10);
     textbackground (1);
     textcolor (15);
     writeln (usr,'┌─── Enter Directory ──────────────┐');
     gotoxy (6,11);
     writeln (usr,'│                                  │');
     gotoxy (6,12);
     writeln (usr,'└──────────────────────────────────┘');
     gotoxy (8,11);
     textcolor (14);
     cursor (true);
     readln (dir);
     cursor (false);
     if doserror <> 0 then begin
       gotoxy (1,14);
       textcolor (15);
       textbackground (0);
       writeln (usr,'Invalid Directory!');
       exit;
     end;
     chdir (dir);
     textbackground (0);
     gotoxy (6,10);
     clreol;
     gotoxy (6,11);
     clreol;
     gotoxy (6,12);
     clreol;
end;

procedure changedir;
var c:char;
    x,y,z,a:integer;
    dir:string[127];

begin
     textbackground (1);
     textcolor (15);
     ahigh (y);
     gotoxy (1,5);
     writeln (usr,'┌────────────────┐');
     writeln (usr,'│ Root Directory │');
     writeln (usr,'│ Other Dir      │');
     writeln (usr,'└────────────────┘');
     textbackground (1);
     textcolor (15);
     gotoxy (2,2);
     ahigh (y);
     repeat
       c:=readkey;
       c:=upcase (c);
     until c in [#77,#75,#72,#80,#27,#13];
     if (c=#77) or (c=#80) then y:=y+1;
     if (c=#75) or (c=#72) then y:=y-1;
     if y=3 then y:=1;
     if y=0 then y:=2;
     if c=#27 then exit;
     if c=#13 then begin;
       case y of
        1:chdir('\');
        2:changedir2;
       end;
     end;
    changedir
end;

procedure makedir;
var c:char;
    x,y,z,a:integer;
    dir:string[127];

begin
     gotoxy (6,10);
     textbackground (1);
     textcolor (15);
     writeln (usr,'┌─── Enter Directory ──────────────┐');
     gotoxy (6,11);
     writeln (usr,'│                                  │');
     gotoxy (6,12);
     writeln (usr,'└──────────────────────────────────┘');
     gotoxy (8,11);
     textcolor (14);
     cursor (true);
     readln (dir);
     cursor (false);
     if doserror <> 0 then begin
      writeln (usr,'Invalid Directory Name!');
      exit;
     end;
     mkdir (dir);
     textbackground (0);
     gotoxy (6,10);
     clreol;
     gotoxy (6,11);
     clreol;
     gotoxy (6,12);
     clreol;
end;

procedure copyproc;
var c:char;
    x,y,z,a:integer;
    dir:string[127];

var cf,ct:string;
begin
     gotoxy (1,8);
     textcolor (14);
     textbackground (1);
     writeln (usr,'┌── Copy ───────────────────────────────────────────┐');
     writeln (usr,'│                                                   │');
     writeln (usr,'└───────────────────────────────────────────────────┘');
     gotoxy (3,9);
     textcolor (15);
     cursor (true);
     readln (cf);
     cursor (false);
     if doserror <> 0 then begin
       writeln (usr,'Invalid Filename or File doesn''t Exist!');
       exit;
     end;
     gotoxy (1,12);
     textcolor (14);
     writeln (usr,'┌── To ─────────────────────────────────────────────┐');
     writeln (usr,'│                                                   │');
     writeln (usr,'└───────────────────────────────────────────────────┘');
     gotoxy (3,13);
     textcolor (15);
     cursor (true);
     readln (ct);
     cursor (false);
     if length(ct)=0 then begin
       writeln (usr,'Invalid Directory or Filename!');
       exit;
     end;
     gotoxy (1,17);
     textcolor (11);
     textbackground (0);
     write (usr,'Copying ');
     textcolor (15);
     write (cf);
     textcolor (11);
     write (usr,' to ');
     textcolor (15);
     write (ct);
     textcolor (11);
     write (usr,'.');
     exec(getenv('COMSPEC'),'/C copy '+cf+' '+ct);
     gotoxy (1,8);
     for a:=8 to 18 do begin
      gotoxy (1,a);
      clreol;
     end;
end;

procedure moveproc;
var mf,mt:string;
var c:char;
    x,y,z,a:integer;
    dir:string[127];

begin
     gotoxy (1,8);
     textcolor (14);
     textbackground (1);
     writeln (usr,'┌── Move ───────────────────────────────────────────┐');
     writeln (usr,'│                                                   │');
     writeln (usr,'└───────────────────────────────────────────────────┘');
     gotoxy (3,9);
     textcolor (15);
     cursor (true);
     readln (mf);
     cursor (false);
     if length(mf)=0 then begin
       writeln (usr,'Invalid Filename!');
       exit;
     end;
     gotoxy (1,12);
     textcolor (14);
     writeln (usr,'┌── To ─────────────────────────────────────────────┐');
     writeln (usr,'│                                                   │');
     writeln (usr,'└───────────────────────────────────────────────────┘');
     gotoxy (3,13);
     textcolor (15);
     cursor (true);
     readln (mt);
     cursor (false);
     if length(mt)=0 then begin
       writeln (usr,'Invalid Directory or Filename!');
       exit;
     end;
     gotoxy (1,16);
     textcolor (11);
     write (usr,'Moving ');
     textcolor (15);
     write (mf);
     textcolor (11);
     write (usr,'to ');
     textcolor (15);
     write (mt);
     textcolor (11);
     write (usr,'.   ');
     exec(getenv('COMSPEC'),'/C MOVE '+MF+' '+MT);
     if doserror <> 0 then writeln (usr,'MOVE.COM not found!');
     textbackground (0);
     for a:=8 to 25 do begin
      gotoxy (1,a);
      clreol;
     end;
end;

procedure bhigh (x:integer);
var c:char;
    y,z,a:integer;
    dir:string[127];

begin
     case x of
       1:begin
             gotoxy (3,4);
             textcolor (15);
             textbackground (7);
             write (usr,' Handle       ');
         end;
       2:begin
             gotoxy (3,5);
             textcolor (15);
             textbackground (7);
             write (usr,' Password     ');
         end;
       3:begin
             gotoxy (3,6);
             textcolor (15);
             textbackground (7);
             write (usr,' Main Level   ');
         end;
       4:begin
             gotoxy (3,7);
             textcolor (15);
             textbackground (7);
             write (usr,' Xfer Level   ');
         end;
       5:begin
             gotoxy (3,8);
             textcolor (15);
             textbackground (7);
             write (usr,' G-File Level ');
         end;
       6:begin
             gotoxy (3,9);
             textcolor (15);
             textbackground (7);
             write (usr,' Xfer Points  ');
         end;
       7:begin
             gotoxy (3,10);
             textcolor (15);
             textbackground (7);
             write (usr,' Time Left    ');
         end;
     end;
end;

procedure execcmds;
var c:char;
    x,y,z,a:integer;
    dir:string[127];
    DD:boolean;
begin
z:=1;
dd:=false;
repeat
     gotoxy (2,3);
     textbackground (1);
     textcolor (15);
     writeln (usr,'┬──────────────┬');
     gotoxy (2,4);
     writeln (usr,'│ Handle       │');
     gotoxy (2,5);
     writeln (usr,'│ Password     │');
     gotoxy (2,6);
     writeln (usr,'│ Main Level   │');
     gotoxy (2,7);
     writeln (usr,'│ Xfer Level   │');
     gotoxy (2,8);
     writeln (usr,'│ G-File Level │');
     gotoxy (2,9);
     writeln (usr,'│ Xfer Points  │');
     gotoxy (2,10);
     writeln (usr,'│ Time Left    │');
     gotoxy (2,11);
     writeln (usr,'└──────────────┘');
     textbackground (1);
     textcolor (15);
     bhigh (z);
     repeat
       c:=readkey;
       c:=upcase(c);
     until c in [#77,#75,#72,#80,#27,#13,#3];
     if (c=#77) or (c=#80) then z:=z+1;
     if (c=#75) or (c=#72) then z:=z-1;
     if z=0 then z:=7;
     if z=8 then z:=1;
     if c=#27 then dd:=true;
     if c=#13 then begin
     textbackground (0);
     gotoxy(1,13);
      case z of
        1:getnewname;
        2:getnewpassword;
        3:getnewlevel;
        4:getnewudlvl;
        5:gfilez;
        6:getnewudpts;
        7:getnewtime;
       end;
     gotoxy (1,13); clreol;
     gotoxy (1,14); clreol;
     gotoxy (1,15); clreol;
     gotoxy (1,16); clreol;
     gotoxy (1,17); clreol;
     gotoxy (1,18); clreol;
     gotoxy (1,19); clreol;
     gotoxy (1,20); clreol;
     gotoxy (1,21); clreol;
     gotoxy (1,22); clreol;
     gotoxy (1,23); clreol;
     end;
     until dd=true;
end;

procedure externalcmds;
var c:char;
    x,y,z,a:integer;
    dir:string[127];
    DD:boolean;

procedure bhigh (x:integer);
var c:char;
    y,z,a:integer;
    dir:string[127];

begin
     case x of
       1:begin
             gotoxy (17,4);
             textcolor (15);
             textbackground (7);
             write (usr,' Run Setup    ');
         end;
       2:begin
             gotoxy (17,5);
             textcolor (15);
             textbackground (7);
             write (usr,' Text Editor  ');
         end;
       3:begin
             gotoxy (17,6);
             textcolor (15);
             textbackground (7);
             write (usr,' ANSI Editor  ');
         end;
     end;
end;

begin
z:=1;          dd:=false;
repeat
     gotoxy (16,3);
     textbackground (1);
     textcolor (15);
     writeln (usr,'┬──────────────┬');
     gotoxy (16,4);
     writeln (usr,'│ Run Setup    │');
     gotoxy (16,5);
     writeln (usr,'│ Text Editor  │');
     gotoxy (16,6);
     writeln (usr,'│ ANSI Editor  │');
     gotoxy (16,7);
     writeln (usr,'└──────────────┘');
     textbackground (1);
     textcolor (15);
     bhigh (z);
     repeat
       c:=readkey;
       c:=upcase(c);
     until c in [#77,#75,#72,#80,#27,#13,#3];
     if (c=#77) or (c=#80) then z:=z+1;
     if (c=#75) or (c=#72) then z:=z-1;
     if z=0 then z:=3;
     if z=4 then z:=1;
     if c=#27 then dd:=true;
     if c=#13 then begin
      textbackground (0);
      clrscr;
      case z of
        1:runconfig;
        2:dotexteditor;
        3:doansieditor;
       end;
     clrscr;
     end;
     until dd=true;
end;

procedure firstbar;
var c:char;
    x,y,z,a,i,ii:integer;
    dir:string[127];
    done:boolean;

begin
done:=false;x:=1;y:=1;z:=1;
     repeat
     textbackground (1);
     textcolor (15);
     gotoxy (1,1);
     write (usr,'┌'); for i:=2 to 79 do begin gotoxy (i,1); write (usr,'─'); end;
     write (usr,'┐');
     gotoxy (1,2);
write (usr,'│ User Editor   External   Shell to DOS   Hang Up   Delete User   Help   Quit  │');
     gotoxy (1,3);
     write (usr,'└'); for i:=2 to 79 do begin gotoxy (i,3); write (usr,'─'); end;
     write (usr,'┘');
     high (x);
     repeat until keypressed;
     repeat
       c:=readkey;
       c:=upcase(c);
     until c in [#77,#75,#13,#3,#27];
     if c=#27 then done:=true;
     if c=#77 then x:=x+1;
     if c=#75 then x:=x-1;
     if x=8 then x:=1;
     if x=0 then x:=7;
     if c=#13 then begin
      textbackground (0);
      case x of
       1:execcmds;
       2:externalcmds;
       3:gotodos;
       4:hangupyn;
       5:nuke;
       6:dohelp;
       7:done:=true;
      end;
       textbackground (0);
       clrscr;
     end;
until done;
textbackground (0);
end;

    begin
     cursor (false);
     clrscr;
     firstbar;
    end; {pulldownmenu}

  Var scom:sstr;
    k:Char;
  Begin
    writeln (^B^M'Please Wait:');
    Pulldownmenu;
    clrscr;
    cursor (true);
    specialcommand:=true;
  End;


procedure specialseries;
begin
  repeat until specialcommand
end;

procedure chat1 (gotospecial:boolean);
var k:char;
    time,cnt,displaywid:integer;
    quit,carrierloss,fromkbd:boolean;
    baudstr,commstr:mstr;

                       (*--Variable Definitions----*)


    xsys     :byte;       (*--X location of cursor for sysop--*)
    ysys     :byte;       (*--Y locaiton of cursor for sysop--*)
    xusr     :byte;       (*--X location of cursor for user---*)
    yusr     :byte;       (*--Y location of cursor for user---*)
    curcolor :byte;       (*--Stores current typists color----*)
    ec       :byte;       (*--Stores old color for speed inc--*)
    initi    :boolean;    (*--Amount of times of initia-------*)
    linebufs :string[80]; (*--Storage of what sysop types-----*)
    linebufu :string[80]; (*--Storage of what usr types-------*)

(*-Initialization of all the variables takes place-------------------------*)
procedure init;
begin
  xsys     :=1;
  ysys     :=4;
  xusr     :=1;
  yusr     :=14;
  curcolor :=1;
  ec       :=1;
  initi    :=true;
  linebufs :='';
  linebufu :='';
end;


(*-Sends to screen location X,Y depending on values passed as X,Y----------*)
procedure sendxy (x,y:byte);
begin
 write(#27+'[',y,';',x,'f');

end;

(*-Sets color if color is same as old, increases speed by not re-setting it*)
Procedure setc;
begin
   ec:=urec.inputcolor;
   if curcolor<>ec then begin
   curcolor:=ec;
   modeminlock:=true;
   ansicolor (curcolor);
   modeminlock:=false;
  end;
end;

(*-Clears entire screen via esc[2J-----------------------------------------*)
Procedure clearscre;
var i:byte;
 begin
for I:=4 to 22 do
  begin
   setc;
   sendxy(1,i);
   write(#27'[K');
  end;
 end;

function parsedate (date:anystr):lstr;
const months: array[1..12] of string[3]=('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');

var m,d,y,inc,gog:sstr;
    year,month,day,dayofweek:word;
begin
 if length(date)<>8 then begin
  parsedate:=date;
  exit;
 end else
 begin
  m:=copy (date,1,2);
  d:=copy (date,4,2);
  y:=copy (date,7,2);
  gog:=months[valu(m)];
  getdate (year,month,day,dayofweek);
  inc:=copy (strr(year),1,2);
  parsedate:=gog+' '+d+' '+inc+y;
 end;
end;

(*---Displays middle line in urec.regular color----------------------------*)
 procedure midline;
 begin
   sendxy(1,13);
   if asciigraphics in urec.config then
   write(^P'───────────────────────────────────────────────────────────────────────────────')
   else
   write(^P'-------------------------------------------------------------------------------');
   sendxy(25,13);
   write (^R'[ '^S'FAQ '+ver+^P' - '^S+parsedate(date)+^R' ]')
   {sendxy(trunc((21-length(sysopname))/2),13);
   write (^R'[ '^S+sysopname+^R' ]');
   sendxy(trunc((24-length(urec.handle))/2)+52,13);
   write (^R'[ '^S+urec.handle+^R' ]');}
 end;
(*-Procedure Clears either lines 4-13 or 14-22 depending on WHERE:boo------*)
Procedure cle (malig:byte);
var i    :byte;  (*Loop variable - no usage*)
begin
if malig=0 then
begin
  for i:=4 to 12 do
 begin
  sendxy(1,i);
  write(#27'[K');
 end;
 sendxy(1,4);
 malig:=0;
 midline;
end;  (*  lines 4-12  *)

if malig=1 then
begin
  for i:=14 to 22 do
 begin
  sendxy(1,i);
  write(#27,'[K');
 end;
 sendxy(1,14);
 malig:=0;
 midline;
end;  (*  lines 14-22  *)


(*NOTE:  Line 13 is taken up by the middle line *)

end;

  procedure wordwrapit(yeanea:byte);
  var cnt       :byte;
      wl        :integer;
      ww        :lstr;
      cutarea   :byte;
      done      :boolean;
  begin
   done:=false;
   cutarea:=0;
   cnt:=80;
   if yeanea=0 then
     begin
    repeat
      if not done and (copy(linebufs,cnt,1)=' ') then cutarea:=cnt;
      if (cutarea>0) and not done then
        begin
         ansicolor(urec.statcolor);
         sendxy(cutarea,ysys);
         write(#27'[K');
         inc(ysys);
         xsys:=1;
         sendxy(xsys,ysys);
         write(copy(linebufs,cutarea+1,80-cutarea));
         xsys:=length(copy(linebufs,cutarea+1,80-cutarea))+1;
         sendxy(xsys,ysys);
         dec(ysys);
         done:=true
        end;      (*If loop     *)
      dec(cnt);   (*decrements c*)
     until cnt=1; (*For CNT loop*)
    linebufs:='';
   end;           (*For YEANEA  *)

   if yeanea=1 then
   begin
   done:=false;
   cutarea:=0;
   cnt:=80;
    repeat
      if not done and (copy(linebufu,cnt,1)=' ') then cutarea:=cnt;
      if (cutarea>0) and not done then
        begin
         ansicolor(urec.inputcolor);
         sendxy(cutarea,yusr);
         write(#27'[K');
         inc(yusr);
         xusr:=1;
         sendxy(xusr,yusr);
         write(copy(linebufu,cutarea+1,80-cutarea));
         xusr:=length(copy(linebufu,cutarea+1,80-cutarea))+1;
         sendxy(xusr,yusr);
         dec(yusr);
         done:=true
        end;      (*If loop     *)
      dec(cnt);   (*decrements c*)
     until cnt=1; (*For CNT loop*)
    linebufu:='';
   end;           (*For YEANEA  *)

end;              (*For wordwrap*)


(*---Places cursor at correct position------------------------------------*)
 Procedure locate;
 begin
   if fromkbd then     (*Checks if typed by sysop*)
 begin

   if (xsys=80) and (ysys<12) then     (*Checks if at end of line*)
  begin
   wordwrapit(0);
   inc(ysys);
   if not ysys=13 then linebufs:='';
  end;
  if (ysys=12) and (xsys=80) then
  begin
  cle(0);
  ysys:=4;
  xsys:=1;
  sendxy(xsys,ysys);
  write(linebufs);
  sendxy(80-length(linebufs)+1,ysys);
  wordwrapit(0);
  inc(ysys);
  sendxy(xsys,ysys);
 end;

  sendxy(xsys,ysys);
  inc(xsys);
 end;
   if not fromkbd then     (*Checks if typed by user*)
 begin
   if (xusr=80) and (yusr<22) then     (*Checks if at end of line*)
  begin
   wordwrapit(1);
   inc(yusr);
   if not yusr=23 then linebufu:='';
  end;
if (yusr=22) and (xusr=80) then
 begin
   cle(1);
   yusr:=14;
   xusr:=1;
   sendxy(xusr,yusr);
   write(linebufu);
   sendxy(80-length(linebufu)+1,yusr);
   wordwrapit(1);
   inc(yusr);
   sendxy(xusr,yusr);
 end;

   sendxy(xusr,yusr);
   inc(xusr);
 end;
end;                   (*end of procedure*)

  procedure instruct;
  var i:integer;
  begin
 for i:=1 to 5 do
   begin
     sendxy(1,i);
     write(#27,'[K');
   end;
    {splitscreen (3);}
    top;
    clrscr;
    {write (usr,'Now in Chat mode. Press [F1] to leave or [F2] for commands.');}
    initi:=false;
    bottom;
    sendxy(1,4);
  end;


  procedure typedchar (k:char);
  begin

   locate;    (*  Puts cursor in right place *)
   begin;
   if fromkbd then linebufs:=linebufs+K else linebufu:=linebufu+K;
    setc;      (*  Sets up color for typing   *)
    write(k)
   end;
  end;

begin
  time:=timeleft;
  carrierloss:=false;
  chatmode:=false;
  writeln (^B^M);
  if wanted in urec.config then begin
    specialmsg ('No longer wanted.');
    urec.config:=urec.config-[wanted];
    writeurec;
  end;
  if eightycols in urec.config then displaywid:=80 else displaywid:=40;
  if gotospecial then begin
    specialseries;
    exit
  end;
  clearbreak;
  nobreak:=true;
  writeln (^M^S,appear);
  writeln (^R'CHAT '^S'IN '^P'['^S,upstring(Timestr(now)),^P']'^M);
  instruct;
  if not initi then
begin
   init;      (*  Sets up variables          *)
   clearscre; (*  Clears screen lines 4-22   *)
   midline;   (*  Draws middle line for chat *)
end;

  quit:=false;

  repeat
    linecount:=0;
    if (not carrierloss) and (not carrier) then begin
      carrierloss:=true;
      writeln (^M'There is no carrier present.'^M)
    end;
    repeat until keyhit or (carrier and (numchars>0));
    fromkbd:=keyhit;
    ingetstr:=true;

    read (directin,k);
    if k=#127 then k:=#8;
    if requestchat1
      then if requestcom
        then
          begin
            quit:=specialcommand;
            if not quit then instruct;
            clearbreak;
            nobreak:=true;
          end
        else
          begin
            unsplit;
            clearscre;
            writeln (^M^S,disappear);
            writeln (^R'CHAT '^S'OUT '^P'['^S,upstring(Timestr(now)),^P']'^M^R);
            quit:=true
          end;
    case ord(k) of
      8:begin
      if (xsys>0) and fromkbd then
       begin
          modeminlock:=true;
          dec(xsys);
          sendxy(xsys,ysys);
          write (' ');
          sendxy(xsys,ysys);
          linebufs:=copy(linebufs,1,length(linebufs)-1);
          modeminlock:=false;
        end;
      if (xusr>0) and not fromkbd then
       begin
          modeminlock:=true;
          dec(xusr);
          sendxy(xusr,yusr);
          write (' ');
          sendxy(xsys,ysys);
          linebufu:=copy(linebufu,1,length(linebufu)-1);
          modeminlock:=false;
        end;
     end;
      0:;
      13:begin
           writeln;
           bottomline;
          if fromkbd then begin
           xsys:=1;
           inc(ysys);
             if (ysys=13) and (xusr>-1) then    (*Checks if at end of row *)
              begin
                 cle(0);
                  setc;
                  ysys:=4;
                  xsys:=1;
                  sendxy(xsys,ysys);
                  write(linebufs);
                  ysys:=5;
                  sendxy(xsys,ysys);
                  setc;
              end;
          sendxy(xsys,ysys);
          linebufs:='';
          end;

          if not fromkbd then begin
           xusr:=1;
           inc(yusr);
             if (yusr=23) and (xusr>-1) then    (*Checks if at end of row *)
              begin
                 cle(1);
                  setc;
                  yusr:=14;
                  xusr:=1;
                  sendxy(xusr,yusr);
                  write(linebufu);
                  yusr:=15;
                  sendxy(xusr,yusr);
                  setc;
              end;
            sendxy(xusr,yusr);
          linebufu:='';
          end;
         end;
      32..126:typedchar (k);
      1..31:if fromkbd and carrier then sendchar(k)
    end
  until quit;
  clearbreak;
  settimeleft (time)
end;

procedure chat2 (gotospecial:boolean);
var k:char;
    time,cnt,displaywid:integer;
    quit,carrierloss,fromkbd:boolean;
    linebuffer:lstr;
    l:byte absolute linebuffer;
    curcolor:byte;
    baudstr,commstr:mstr;

  procedure instruct;
  begin
   {splitscreen (3);}
    top;
    clrscr;
    {write (usr,'Now in Chat mode. Press [F1] to leave or [F2] for commands.');}
    bottom
  end;

  procedure wordwrap;
  var cnt,wl:integer;
      ww:lstr;
  begin
    ww:='';
    cnt:=displaywid;
    while (cnt>0) and (linebuffer[cnt]<>' ') do cnt:=cnt-1;
    if cnt=0 then ww:=k else begin
      ww:=copy(linebuffer,cnt+1,255);
      wl:=length(ww)-1;
      if wl>0 then begin
        for cnt:=1 to wl do write (^H);
        for cnt:=1 to wl do write (' ')
      end
    end;
    writeln;
    ansicolor (curcolor);
    write (ww);
    linebuffer:=ww
  end;

  procedure typedchar (k:char);
  var ec:byte;
  begin
    l:=l+1;
    linebuffer[l]:=k;
    if fromkbd then ec:=urec.regularcolor else ec:=urec.inputcolor;
    if curcolor<>ec then begin
      curcolor:=ec;
      ansicolor (curcolor)
    end;
    if l=displaywid then wordwrap else write(k)
  end;

begin
  time:=timeleft;
  carrierloss:=false;
  chatmode:=false;
  writeln (^B^M);
  if wanted in urec.config then begin
    specialmsg ('No longer wanted.');
    urec.config:=urec.config-[wanted];
    writeurec;
  end;
  if eightycols in urec.config then displaywid:=80 else displaywid:=40;
  if length(chatreason)>0 then specialmsg ('[Chat Reason: '+chatreason+']');
  chatreason:='';
  if gotospecial then begin
    specialseries;
    exit
  end;
  clearbreak;
  nobreak:=true;
  writeln (^M^S,appear);
  writeln (^R'CHAT '^S'IN '^P'['^S,upstring(Timestr(now)),^P']'^M^R);
  instruct;
  quit:=false;
  l:=0;
  curcolor:=urec.regularcolor;
  repeat
    linecount:=0;
    if (not carrierloss) and (not carrier) then begin
      carrierloss:=true;
      writeln (^M'There is no carrier present.'^M)
    end;
    repeat until keyhit or (carrier and (numchars>0));
    fromkbd:=keyhit;
    ingetstr:=true;
    read (directin,k);
    if k=#127 then k:=#8;
    if requestchat2
      then if requestcom
        then
          begin
            quit:=specialcommand;
            if not quit then instruct;
            clearbreak;
            nobreak:=true;
            l:=0
          end
        else
          begin
            unsplit;
            writeln (^M^S,disappear);
            writeln (^R'CHAT '^S'OUT '^P'['^S,upstring(Timestr(now)),^P']'^M);
            quit:=true
          end;
    case ord(k) of
      8:if l>0 then begin
          write (k+' '+k);
          l:=l-1
        end;
      0:;
      13:begin
           writeln;
           bottomline;
           l:=0
         end;
      32..126:typedchar (k);
      1..31:if fromkbd and carrier then sendchar(k)
    end
  until quit;
  clearbreak;
  settimeleft (time)
end;

begin
end.